home *** CD-ROM | disk | FTP | other *** search
- Option Explicit
-
- Global Const VB_LNG_FRENCH = 1
- Global Const VB_LNG_DUTCH = 2
- Global Const VB_LNG_GERMAN = 3
- Global Const VB_LNG_ENGLISH = 4
- Global Const VB_LNG_ITALIAN = 5
- Global Const VB_LNG_SPANISH = 6
-
- Const MB_MESSAGE_LEFT = 0
-
- 'Don't change any variables and their value below
-
- Const ID_ITEMS = 16
-
- Type HNDERRtype
- ModuleName As String * 12
- RoutineHandle As String * 4
- RoutineName As String * 82
- CrLf As String * 2
- End Type
-
- Dim FileLNG As String
-
- Dim FileHND As String
-
- Dim FileLOG As String
-
- Dim IDArray(0 To ID_ITEMS) As Integer
-
- Dim Language As Integer
- Dim AutoLog As Integer
- Dim WaitingTimeForReaction As Integer
- Dim DefaultButton As Integer
-
- Dim HNDERR As HNDERRtype
-
- Sub mcClearID ()
- Call cClearID(IDArray(0))
- End Sub
-
- Function mcGetID (nPos As Integer)
- mcGetID = cGetID(IDArray(0), nPos)
- End Function
-
- Function mcGetLanguageID (LanguageID As Integer) As String
-
- Dim RetLanguage As String
-
- Select Case LanguageID
- Case VB_LNG_FRENCH
- RetLanguage = "VFR"
- Case VB_LNG_DUTCH
- RetLanguage = "VNL"
- Case VB_LNG_GERMAN
- RetLanguage = "VDE"
- Case VB_LNG_ENGLISH
- RetLanguage = "VUK"
- Case VB_LNG_ITALIAN
- RetLanguage = "VIT"
- Case VB_LNG_SPANISH
- RetLanguage = "VSP"
- Case Else
- RetLanguage = "VUK"
- End Select
-
- If (LanguageID > 0) Then
- Language = LanguageID
- Else
- Language = VB_LNG_ENGLISH
- End If
-
- mcGetLanguageID = RetLanguage
-
- End Function
-
- Function mcIDErrorHandler (nErr As Integer) As Integer
-
- ' check if this a correct Error passed
- If (nErr = 0) Then
- 'if no, resume next
- mcIDErrorHandler = True
- Exit Function
- End If
-
- Dim RoutineCount As Integer
- Dim RoutineNumber As Integer
- Dim RoutineStack As String
- Dim TotalRoutines As Integer
- Dim BlankLines As Integer
- Dim Chan As Integer
- Dim StopExit As Integer
- Dim TimeOut As Long
- Dim ButtonsConfig As Integer
- Dim ErrorTitle As String
-
- ' some initializations
- RoutineStack = ""
- TotalRoutines = 0
- BlankLines = 0
- StopExit = False
- ButtonsConfig = 0
- ErrorTitle = ""
- RoutineStack = RoutineStack + mcReadText("0", "")
-
- ' find the next valid unused file number.
- Chan = FreeFile
-
- ' open the file with the definition of each routines (file must be in the WINDOWS directory)
- Close #Chan
- Open FileHND For Random Shared As #Chan Len = Len(HNDERR)
-
- ' get the stack of the routines
- For RoutineCount = 0 To ID_ITEMS
- ' get the number of the routine
- RoutineNumber = mcGetID(RoutineCount)
- ' if there a valid routine number
- If (RoutineNumber > 0) Then
- ' yes, read the definition of the routine
- Get #Chan, RoutineNumber, HNDERR
- ' form the stack of the routines founden to display
- RoutineStack = RoutineStack + HNDERR.ModuleName + Chr$(9) + HNDERR.RoutineHandle + Chr$(9) + Trim$(HNDERR.RoutineName) + Chr$(13)
- ' count the routines to display
- TotalRoutines = TotalRoutines + 1
- Else
- ' no, exit from reading the stack
- Exit For
- End If
- Next RoutineCount
-
- ' close the open file
- Close #Chan
-
- ' check if the default button must be activated
- If (DefaultButton = True) Then
- ' yes, RETRY and CANCEL with RETRY is the default
- ButtonsConfig = 5 Or 0
- Else
- ' no, RETRY and CANCEL with CANCEL is the default
- ButtonsConfig = 5 Or 256
- ' yes, add text for RETRY after timeout or action
- RoutineStack = RoutineStack & Chr$(13) & Chr$(13) & "program will be stopped"
- End If
-
- ' set the error title
- ErrorTitle = mcReadText("1", nErr & "~" & Error$(nErr))
-
- ' check if one routine has been founded
- If (Len(RoutineStack) > 0) Then
- ' check the time out
- TimeOut = WaitingTimeForReaction * (163840 Or 524288)
- ' display remaining blank lines
- BlankLines = (8 - TotalRoutines) - (TimeOut = 0)
- For RoutineCount = 0 To BlankLines
- RoutineStack = RoutineStack + Chr$(13)
- Next RoutineCount
- ' add some text for management
- RoutineStack = RoutineStack & mcReadText("2", "")
- ' check if a timeout must be used
- If (TimeOut <> 0) Then
- ' yes, add text depending of the default button
- RoutineStack = RoutineStack & mcReadText("3", "") & " "
- ' if default is RETRY then display 'continue' else 'stop'
- If (DefaultButton = True) Then
- RoutineStack = RoutineStack & mcReadText("4", "")
- Else
- RoutineStack = RoutineStack & mcReadText("5", "")
- End If
- End If
- ' display the error message box
- StopExit = (cLngMsgBox(Language, RoutineStack, MB_MESSAGE_LEFT Or TimeOut Or ButtonsConfig Or 16, ErrorTitle) = 2)
- ' yield process
- DoEvents
- End If
-
- ' check if an auto logging must be performed
- If (AutoLog = True) Then
-
- ' open the logging file in append mode
- Close #Chan
- Open FileLOG For Append Shared As #Chan
-
- ' save the error and his description
- Print #Chan, ErrorTitle; " "; mcReadText("6", Date$ & "~" & Time$)
- Print #Chan, ""
- ' save the full stack name of each routines founden
- Print #Chan, RoutineStack
- Print #Chan, ""
- ' check if the CANCEL button pushed or TimeOut
- If (StopExit = True) Then
- ' yes stop by operator, save text for CANCEL
- Print #Chan, mcReadText("7", "")
- Else
- ' no, retry by operator, save text for RETRY
- Print #Chan, mcReadText("8", "")
- End If
- ' save separator
- Print #Chan, String$(78, "-")
-
- ' close the file
- Close #Chan
-
- End If
-
- ' if stop the program the END the application
- If (StopExit = True) Then End
-
- ' no stop, resumes to next line in the main application
- mcIDErrorHandler = True
-
- End Function
-
- Sub mcPopID (ID As Integer)
- Call cPopID(IDArray(0), ID)
- End Sub
-
- Sub mcPopLastID ()
- Call cPopLastID(IDArray(0))
- End Sub
-
- Sub mcPushID (ID As Integer)
- Call cPushID(IDArray(0), ID)
- End Sub
-
- Function mcReadText (TextOrder As String, InsertText As String) As String
-
- Dim Tmp As String
- Dim BasisText As String
-
- ' read the text in the language file
- BasisText = cGetIni("VBHNDERR", TextOrder, "?", FileLNG)
-
- ' insert some text if any
- Tmp = cInsertBlocks(BasisText, InsertText)
-
- ' change all º by a CR and all ú by TAB
- Call cChangeChars(Tmp, "ºú", Chr$(13) + Chr$(9))
-
- mcReadText = Tmp
-
- End Function
-
- Sub mcInitID (mcLanguage As Integer, mcAutoLog As Integer, mcWaitingTimeForReaction As Integer, mcDefaultButton As Integer)
-
- 'mcLanguage 'set to TRUE if you want to use English language
- 'set to LNG_X if you want to use another language
-
- 'mcAutoLog 'set to TRUE if you want to make a logging of all errors
- 'set to FALSE if no logging
-
- 'mcWaitingTimeForReaction 'set to TRUE if no waiting time
- 'set to 1 for 10 seconds, 2 for 20 seconds, 3 for 30 seconds) to wait before automatic continue
-
- 'mcDefaultButton 'set to TRUE if you want to set the first button als default (RETRY = continue after waiting time has occured)
- 'set to FALSE if you want to set the second button als default (CANCEL = stop after waiting time has occured)
-
- Call mcClearID
-
- Language = mcLanguage
- AutoLog = mcAutoLog
- WaitingTimeForReaction = mcWaitingTimeForReaction
- DefaultButton = mcDefaultButton
-
- FileLNG = cGetWindowsDirectory() + "\VBHNDERR." + mcGetLanguageID(Language)
-
- FileHND = cGetWindowsDirectory() + "\MODULES.HND"
-
- FileLOG = cGetWindowsDirectory() + "\MODULES.LOG"
-
- End Sub
-